home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / LISP Related / U. Mass AI & LISP Tools / INTERFACE / Dialogue.lisp next >
Encoding:
Text File  |  1990-06-24  |  30.0 KB  |  699 lines  |  [TEXT/CCL ]
  1. ; (c) Copyright 1990 by University of Massachusetts. All rights reserved.
  2. ; This software was conceived, designed, and written by Dan Suthers 
  3. ; while supported by the National Science Foundation under grant number
  4. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  5. ; CA.  Partial support was also received from the Office of Naval Research
  6. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  7. ; Mr. Suthers created this software under his own initiative while in an 
  8. ; academic relationship with the University of Massachusetts.  The above
  9. ; copyright notice was a condition placed by University lawyers on approval
  10. ; of distribution of this software by Apple Computer, and is not meant to
  11. ; imply that this software was created in an employment or "work for hire"
  12. ; relationship between the University and Mr. Suthers.
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; File:         DIALOGUE.lisp
  15. ; Author:       Dan Suthers
  16. ; Created:      27-Nov-87 20:38:00
  17. ; Modified:     24-Jun-90 23:43:30 (Dan Suthers)
  18. ; Language:     LISP
  19. ; Package:      WIND
  20. ;
  21. ; Description:  Defines "Dialogue" functions for interactions such as 
  22. ;               informing the user of something, asking a y-n or multiple
  23. ;               choice question, etc.  These will be in popup windows on
  24. ;               some machines, and ASCII terminal I/O on all others.
  25. ;
  26. ; (c) Copyright 1987, by Daniel D. Suthers
  27. ;                        Department of Computer and Information Science
  28. ;                        University of Massachusetts
  29. ;                        Amherst, Massachusetts 01003
  30. ;
  31. ; This software was conceived, designed, and written by Dan Suthers 
  32. ; while supported by the National Science Foundation under grant number
  33. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  34. ; CA.  Partial support was also received from the Office of Naval Research
  35. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  36. ; I wish to acknowledge the generous support of Beverly Woolf, who obtained 
  37. ; the above grants and encouraged me to pursue my own research interests in
  38. ; her lab.  This work would not have been possible without the resources and
  39. ; stimulating environment of the Computer and Information Science department.
  40. ;
  41. ; Permission to use, modify, and distribute this software is granted subject 
  42. ; to the following restrictions and understandings:
  43. ; 1. The file header, including this notice, shall be retained, and may be
  44. ;    extended to include documentation of modifications to the software.
  45. ; 2. This material is for nonprofit educational and research purposes only.
  46. ;    Users are requested, but not required, to inform Mr. Suthers of any 
  47. ;    noteworthy uses of this software.
  48. ; 3. Mr. Suthers and the University of Massachusetts make no warantee or
  49. ;    representation that the operation of this software will be error free,
  50. ;    and are under no obligation to provide any services.
  51. ; 4. Any user of such software agrees to indemnify and hold harmless Mr.
  52. ;    Suthers and the University of Massachusetts from all claims arising 
  53. ;    out of the use or misuse of this software, or arising out of any 
  54. ;    accident, injury, or damage whatsoever, and from all costs, counsel
  55. ;    fees, and liabilities incurred in or about any such claim, action, or
  56. ;    proceeding brought thereon.
  57. ; 5. All materials and reports developed as a consequence of the use of 
  58. ;    this software shall duly acknowledge such use, in accordance with
  59. ;    the usual standards of acknowledging credit in academic research.
  60. ;
  61. ; Status:       Approved for distribution.  
  62. ;               Supported machines and last test dates:
  63. ;                 Hewlett Packard 9000        02/27/88  Dan Suthers
  64. ;                   Windows 9000 (if :W9000 on *features*), ASCII
  65. ;                 Macintosh II Coral/Allegro  12/14/89 Dan Suthers
  66. ;                   Coral Common Lisp Dialogues used.
  67. ;                 Texas Instruments Explorer  01/20/88 Dan Suthers
  68. ;                   TV package (version 2) popup windows used.
  69. ;                   (Needs version 3 rewrite)
  70. ;                 VAX/VMS                     02/27/88 Dan Suthers
  71. ;                   Plain vanilla ASCII interaction tested here.
  72. ;
  73. ; Changes:
  74. ;  24-Jan-88 Added get-string-default-dialogue 
  75. ;  28-Jan-88 CCL Screen dependent constants -> parameters
  76. ;  31-Jan-88 get-string-default-dialogue adjusts size for large default strings.
  77. ;    Values of message-size reversed.
  78. ;  01-Feb-88 Allegro: get-string dialogues made a touch wider.
  79. ;  04-Feb-88 Allegro: Minor changes to get rid of whitespace, and cancel is no 
  80. ;     longer default button.
  81. ;  11-Feb-88 HP: Added trim-right-margin to w9000 version.
  82. ;  27-Feb-88 HP: Changed windows9000 file to push :W9000 on *features*. User now 
  83. ;     responsible for loading that file, and #+:W9000 instead of #+HP.
  84. ;  28-Feb-88 Menu-dialogue now has OK button, the mouse click selects item but 
  85. ;     does not return from menu as before.
  86. ;  07-Jul-88 Updated for Allegro 1.2.
  87. ;  07-Jan-89 Bigger get-string-dialogue entry item.
  88. ;  17-Apr-89 Optimization declarations added.  Also size of CCL dialogues
  89. ;     now computed for messages and get-string.
  90. ;  06-Nov-89 Menu dialogues default selection to first item for convenience.
  91. ;  14-Dec-89 Fixed menus to allow double click return.
  92. ;  21-Dec-89 To satisfy need to specify popup location in CCL without loosing 
  93. ;     upward compatibility, added somewhat ugly *dialogue-position* mechanism.
  94. ;  11-Jan-90 Menus now show 7 items; 5 was cramped for fast scrolling.
  95. ;  30-Jan-90 Updated for version 1.3.1 (:default-button has to be specified
  96. ;     in button item's init list).
  97. ;  17-Feb-90 Added *multiple-menu-cells-to-select*, a hack to let some
  98. ;     applications say what cells should be selected in CCL.  Added 
  99. ;     window-key-event-handler to menus to scroll to item starting with
  100. ;     character given.
  101. ;  26-Apr-90 DS Sick of CCL's bad computation of y-or-n-dialog size, I
  102. ;     now compute size myself so text is not cut off.  Also reorganized
  103. ;     all size computations to make better use of MESSAGE-SIZE-IN-POINTS,
  104. ;     and added MIN-RECT and SCREEN-RECT to help set limits.  MAX-RECT
  105. ;     fixed to evaluate its arguments only once.
  106. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  107.  
  108. (in-package 'WIND :use '("LISP"))
  109.  
  110. (export '(
  111.           *dialogue-position*
  112.           *multiple-menu-cells-to-select*
  113.  
  114.           message-dialogue
  115.           y-or-n-dialogue
  116.           get-string-default-dialogue
  117.           get-string-dialogue
  118.           menu-dialogue
  119.           multiple-menu-dialogue
  120.  
  121.           ;; Helpers which may be of use ...
  122.           message-size
  123.           message-size-in-points
  124.           trim-right-margin
  125.  
  126.           ))
  127.  
  128. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  129.  
  130. (defconstant *NEWLINE* (char (format nil "~%") 0))
  131.  
  132. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  133. ;;;
  134. ;;;                               HELPERS
  135. ;;;
  136. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  137.  
  138. ;;; Returns two values: number of columns and number of rows needed to
  139. ;;; print the message in an ascii-based window.
  140.  
  141. (defun MESSAGE-SIZE (message)
  142.   (declare (optimize (safety 1) (space 2) (speed 3)))
  143.   (do ((i 0 (1+ i))
  144.        (messlen (length message))
  145.        (colcount 0)
  146.        (maxcol   1)
  147.        (maxrow   1))
  148.       ((= i messlen) (values (max colcount maxcol) maxrow))
  149.     (declare (fixnum i messlen colcount maxcol maxrow))
  150.     (cond ((eql (char message i) *newline*)
  151.            (incf maxrow)
  152.            (if (> colcount maxcol) (setq maxcol colcount))
  153.            (setq colcount 0))
  154.           ((incf colcount)))))
  155. (proclaim '(inline message-size))
  156.  
  157. ;;; Reformat a string to be within a given right margin width, by inserting 
  158. ;;; newlines where there were spaces.  If this is not possible, it gives up.
  159.  
  160. (defun TRIM-RIGHT-MARGIN (message margin-column)
  161.   "trim-right-margin <message> <margin-column>                      [Function]
  162.   Returns a string with the same contents except newlines are inserted 
  163.   to trim to the indicated margin."
  164.   (declare (optimize (safety 1) (space 2) (speed 3)))
  165.   (do ((ptr 0 (1+ ptr))            ; traverses message
  166.        (position 0 (1+ position))  ; counts current column
  167.        (messlen (length message)))
  168.       ((= ptr messlen) message)
  169.     (declare (fixnum ptr position messlen))
  170.     (cond ((eql (char message ptr) *newline*)
  171.            (setf position 0))
  172.           ((> position margin-column)
  173.            ;; Must break before here.  Search back to space and
  174.            ;;  replace it with newline.
  175.            (do ((backptr ptr (1- backptr)))
  176.                ((<= backptr 0))
  177.              (declare (fixnum backptr))
  178.              (if (eql (char message backptr) #\ )
  179.                  (setf (char message backptr) *newline*
  180.                        ptr backptr ; restart here
  181.                        backptr 0
  182.                        position 0)))))))
  183. (proclaim '(inline trim-right-margin))
  184.  
  185. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  186. ;;;
  187. ;;;                             TI EXPLORERS
  188. ;;;
  189. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  190.  
  191. #+:TI  (use-package 'tv)
  192. ;;; Makes a choice list into an item list, since the displayed label
  193. ;;; and the value returned are distinguished on the TI.
  194.  
  195. #+:TI
  196. (defun MAKE-ITEM-LIST (choices)
  197.   (declare (optimize (safety 1) (space 2) (speed 3)))
  198.   (mapcar #'(lambda (choice) (list choice :value choice))
  199.       choices))
  200. #+:TI (proclaim '(inline make-item-list))
  201.  
  202. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  203. ;;;
  204. ;;;                       CORAL COMMON LISP
  205. ;;;
  206. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  207.  
  208. #+:CCL (use-package :ccl)
  209.  
  210. #+:CCL 
  211. (defvar *DIALOGUE-POSITION* :centered
  212.   "Determines where popup dialogues in this package appear. (Upward 
  213.   compatibility precludes an additional argument to the functions.)")
  214.  
  215. #+:CCL
  216. (defvar *MULTIPLE-MENU-CELLS-TO-SELECT* nil
  217.   "Determines what cells are selected in multiple-menu-dialogue.
  218.   Should be a list of index positions.")
  219.  
  220. #+:CCL
  221. (defmacro MESSAGE-SIZE-IN-POINTS (message)
  222.   ;; Computes rectangle space in points required to represent the message
  223.   ;; in the standard dialog font.
  224.   `(multiple-value-bind 
  225.      (columns rows)
  226.      (message-size ,message)
  227.      (declare (fixnum columns rows))
  228.      ;; Compensate for excess padding in big messages.
  229.      (make-point (if (< columns 50) (* 9 columns) (* 8 columns))
  230.                  (if (< rows 5) (* 22 rows) (* 20 rows)))))
  231.  
  232. #+:CCL
  233. (eval-when (compile eval)
  234.  
  235.   (defmacro MAX-RECT (point1 point2)
  236.     ;; Returns a rectangle point with h,v maximum of those in points.
  237.     `(let* ((point1-val ,point1)
  238.             (point2-val ,point2)
  239.             (point1-h (point-h point1-val))
  240.             (point1-v (point-v point1-val))
  241.             (point2-h (point-h point2-val))
  242.             (point2-v (point-v point2-val)))
  243.        (declare (fixnum point1-h point1-v point2-h point2-v))
  244.        (make-point (max point1-h point2-h) (max point1-v point2-v))))
  245.  
  246.   (defmacro MIN-RECT (point1 point2)
  247.     ;; Returns a rectangle point with h,v minimum of those in points.
  248.     `(let* ((point1-val ,point1)
  249.             (point2-val ,point2)
  250.             (point1-h (point-h point1-val))
  251.             (point1-v (point-v point1-val))
  252.             (point2-h (point-h point2-val))
  253.             (point2-v (point-v point2-val)))
  254.        (declare (fixnum point1-h point1-v point2-h point2-v))
  255.        (make-point (min point1-h point2-h) (min point1-v point2-v))))
  256.  
  257.   (defmacro SCREEN-RECT ()
  258.     '(make-point *screen-width* 
  259.       (- *screen-height* *menubar-bottom*)))
  260.  
  261.   ) ; eval-when
  262.  
  263. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  264. ;;;
  265. ;;;                                HP 9000
  266. ;;;                      Windows 9000 and X Windows
  267. ;;;
  268. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  269. ;;;
  270. ;;; There are three potential ways of interacting on the HP 9000: X Windows, 
  271. ;;; Windows9000, or ASCII.  The user is responsible for first loading any
  272. ;;; support files that are needed for the window system, and recording the
  273. ;;; loaded window system on *featurs*.  For example, the Windows9000.l file
  274. ;;; has been patched to push :W9000 onto *features*.
  275. ;;;
  276. ;;; DIALOGUE has been written so that loading the same UNcompiled source will
  277. ;;; work on any machine and window system it supports.  Unfortuantely there
  278. ;;; is a tradeoff for compiled files.  Either we have unnecessary code in
  279. ;;; the compiled version on a given machine (eg. run time conditionalization
  280. ;;; for HP's between W9000, X, and ASCII), or we need multiple versions of
  281. ;;; compiled DIALOGUE.b, one for each window system.  The latter option has
  282. ;;; been taken, for efficiency and to simplify the following code (not mix
  283. ;;; #+ and run time conditionalization constructs).  It is suggested that 
  284. ;;; the user place the appropriate version of DIALOGUE.b in the same 
  285. ;;; directory as the supporting windows file, with the ASCII version of 
  286. ;;; DIALOGUE.b in the generic utilities directory.  Then one can switch 
  287. ;;; between window systems by changing which directory appears first on HP 
  288. ;;; Common Lisp's sys:*require-directories*.
  289. ;;;
  290. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  291. ;;;                              Windows 9000
  292. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  293.  
  294. #+:W9000 (use-package :W9000)
  295.  
  296. #+:W9000 (defvar *popup-fd* nil)
  297. #+:W9000 (defvar *popup-stream* nil)
  298. #+:W9000 (defvar *popup-path* (make-string 50))
  299.  
  300. #+:W9000 (create-window *popup-fd* *popup-stream* "POPUP" 
  301.             *popup-path* 5 5 60 10 60 10 60 10
  302.             "/usr/lib/raster/8x16/lp.8U"
  303.             "/usr/lib/raster/8x16/lp.b.8U"
  304.             2 0)
  305.  
  306. ;;; Our W9000 menus can't deal with line feeds in labels. This will turn
  307. ;;; a single string with line feeds into a list of strings.
  308.  
  309. #+:W9000
  310. (defun SPLIT-LINES (string)
  311.   (declare (optimize (safety 1) (space 2) (speed 3)))
  312.   (do ((lines nil)
  313.        (pos nil))
  314.       ((string= string "") (reverse lines))
  315.     (setq pos (position *newline* string))
  316.     (if pos
  317.     (progn (push (subseq string 0 pos) lines)
  318.            (setq string (subseq string (1+ pos) (length string))))
  319.     (progn (push string lines)
  320.            (setq string "")))))
  321. #+:W9000 (proclaim '(inline split-lines))
  322.  
  323. #+:W9000
  324. (defun MAKE-ITEM-LIST (choices)
  325.   (declare (optimize (safety 1) (space 2) (speed 3)))
  326.   (mapcar #'(lambda (opt)
  327.           (list (cond ((or (numberp opt) (listp opt)) 
  328.                (format nil "~A" opt))
  329.                     (t (string opt)))
  330.             opt))
  331.       choices))
  332. #+:W9000 (proclaim '(inline make-item-list))
  333.  
  334. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  335. ;;;
  336. ;;;                          THE FUNCTIONS
  337. ;;;
  338. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  339.  
  340. (defun MESSAGE-DIALOGUE (format &rest args &aux message)
  341.   "message-dialogue <format> &rest <args> - Function
  342.   Displays a message in a pop-up window, returning NIL after a
  343.   user mouse click or keyboard action (depending on the machine)."
  344.   (declare (optimize (safety 1) (space 2) (speed 3)))
  345.   (setq message (apply #'format nil format args))
  346.   #+:CCL (progn 
  347.            (trim-right-margin message 70)
  348.            (message-dialog message
  349.                            :position *dialogue-position*
  350.                            :size (min-rect
  351.                                   (add-points (message-size-in-points message)
  352.                                               #.(make-point 80 30)) ; for buttons
  353.                                   (screen-rect))))
  354.   #+:TI 
  355.   (tv:mouse-confirm message " Click here or move mouse when done reading ")
  356.   #+:W9000 
  357.   (do ((response nil)
  358.        (menu-items (nconc (split-lines (trim-right-margin message 60))
  359.               (list :line 
  360.                 '(" Click here when done reading " T)))))
  361.       (response (second response))
  362.       (setq response (W9000:make-and-activate-menu
  363.               *popup-fd* " Message Dialogue " menu-items)))
  364.   #-(or :ccl :ti :W9000)
  365.   (progn
  366.     (format T "~%~A" (trim-right-margin message 60))
  367.     (format T "~%(Press Return to continue):")
  368.     (clear-input T)
  369.     (read-char)) ; VAX read-char only returned on RETURN!
  370.   nil)
  371.  
  372. (defun Y-OR-N-DIALOGUE (format &rest args &aux message)
  373.   "y-or-n-dialogue <format> &rest <args> - Function
  374.   Does a popup-window based y-or-n-p, using format arguments."
  375.   (declare (optimize (safety 1) (space 2) (speed 3)))
  376.   (setq message (apply #'format nil format args))
  377.   #+:CCL 
  378.   (progn
  379.     (trim-right-margin message 60)
  380.     (y-or-n-dialog 
  381.      message
  382.      :position *dialogue-position*
  383.      :size (min-rect (max-rect  (add-points (message-size-in-points message)
  384.                                             #.(make-point 10 100)) ; for buttons
  385.                                #.(make-point 220 100)) ; minimum size
  386.                      (screen-rect))))
  387.  
  388.  
  389.   #+:TI  
  390.   (tv:mouse-confirm message)
  391.   #+:W9000   
  392.   (do ((response nil)
  393.        (menu-items (nconc (split-lines (trim-right-margin message 60))
  394.               (list :line 
  395.                 '(" Click here for YES " T) 
  396.                 '(" Click here for NO " nil)))))
  397.       (response (second response))
  398.       (setq response (make-and-activate-menu
  399.               *popup-fd* " Yes or No Dialogue " menu-items)))
  400.   #-(or :ccl :ti :W9000) 
  401.   (y-or-n-p (trim-right-margin message 60)))
  402.  
  403. (defun GET-STRING-DEFAULT-DIALOGUE (default format &rest args &aux message)
  404.   "get-string-default-dialogue <default> <format> &rest <args>     - Function
  405.   Displays a formatted message in a popup window (machine permitting),
  406.   and asks the user to enter response read in as a string.  The first
  407.   argument is the default string, returned if the user responds with
  408.   a return.  Otherwise identical to get-string-dialogue."
  409.   (declare (optimize (safety 1) (space 2) (speed 3)))
  410.   (setq message (apply #'format nil format args))
  411.   #+:CCL (progn 
  412.            (trim-right-margin message 60)
  413.            (get-string-from-user
  414.             message default 
  415.             :position *dialogue-position*
  416.             :size (min-rect (max-rect (add-points (message-size-in-points message)
  417.                                                   #.(make-point 80 70)) ; for buttons
  418.                                       #.(make-point 400 80)) ; minimum size
  419.                             (screen-rect))))
  420.   #-(or :ccl)
  421.   (progn
  422.     (format t "~%~A~%Default: ~S~%(Enter response, or Return for default):"
  423.             (trim-right-margin message 60) default)
  424.     (clear-input T)
  425.     (read-line)))
  426.  
  427. (defun GET-STRING-DIALOGUE (format &rest args)
  428.   "get-string-dialogue <format> &rest <args>              - Function
  429.   Displays a formatted message in a popup window (machine permitting),
  430.   and asks the user to enter response read in as a string."
  431.   (declare (optimize (safety 1) (space 2) (speed 3)))
  432.   (apply #'get-string-default-dialogue "" format args))
  433.  
  434. ;;; CCL's select-item-from-list does not allow multi-line prompts.
  435.  
  436. (defun MENU-DIALOGUE (choices format &rest args &aux message)
  437.   "menu-dialogue <choices> <format> &rest <args> - Function
  438.   Prompting with a message constructed from <format> applied to <args>, 
  439.   provides a menu of <choices>, of which the user may choose exactly
  440.   one.  Returns the chosen item."
  441.   (declare (optimize (safety 1) (space 2) (speed 3)))
  442.   (setq message (apply #'format nil format args))
  443.   #+:CCL 
  444.   (progn
  445.     (trim-right-margin message 60)
  446.     (let* ((message-item
  447.             (oneof *static-text-dialog-item*
  448.                    :dialog-item-text message
  449.                    :dialog-item-size (message-size-in-points message)))
  450.            (menu-item
  451.             (oneof *sequence-dialog-item*
  452.                    :dialog-item-position 
  453.                    (make-point 5 (+ 10 (ask message-item (point-v (dialog-item-size)))))
  454.                    :dialog-item-size  (make-point 350 142)
  455.                    :cell-size         (make-point 350 16)
  456.                    :table-vscrollp t
  457.                    :visible-dimensions  (make-point 1 7)
  458.                    :table-sequence choices
  459.                    :dialog-item-action
  460.                    '(if (double-click-p)
  461.                       (if (selected-cells)
  462.                         (return-from-modal-dialog
  463.                          (cell-contents (first (selected-cells))))
  464.                         (ed-beep)))))
  465.            (ok-button
  466.             (oneof *button-dialog-item*
  467.                    :dialog-item-text " OK "
  468.                    :dialog-item-position 
  469.                    (make-point 395
  470.                                (+ 20 (point-v (ask message-item (dialog-item-size)))))
  471.                    :dialog-item-action
  472.                    #'(lambda ()
  473.                        (ask menu-item 
  474.                          (if (selected-cells)
  475.                            (return-from-modal-dialog
  476.                             (cell-contents (first (selected-cells))))
  477.                            (ed-beep))))
  478.                    :default-button t))
  479.            (cancel-button
  480.             (oneof *button-dialog-item*
  481.                    :dialog-item-text "CANCEL"
  482.                    :dialog-item-position
  483.                    (make-point 385
  484.                                (+ 60 (point-v (ask message-item (dialog-item-size)))))
  485.                    :dialog-item-action
  486.                    #'(lambda () (return-from-modal-dialog :cancel))))
  487.            ;; window size
  488.            (w-h 
  489.             (min (- *screen-width* 20)
  490.                  (max 
  491.                   (+ 10 (point-h (ask message-item (dialog-item-size))))
  492.                   (+ 100 (point-h (ask menu-item (dialog-item-size)))))))
  493.            (w-v
  494.             (min (- *screen-height* *menubar-bottom* 20)
  495.                  (+ (point-v (ask message-item (dialog-item-size)))
  496.                     (point-v (ask menu-item (dialog-item-size))))))
  497.            (the-dialogue
  498.             (oneof *dialog*
  499.                    :window-title "Menu Dialogue"
  500.                    :window-position *dialogue-position*
  501.                    :window-size (make-point w-h w-v)
  502.                    :window-show t
  503.                    :window-type :double-edge-box
  504.                    :dialog-items
  505.                    (list ok-button cancel-button message-item menu-item))))
  506.       (declare (fixnum w-h w-v))
  507.       ;; Alpha keystrokes will scroll sequence item to the first entry starting
  508.       ;; with <char>. (Assumes list is sorted.)
  509.       (defobfun (window-key-event-handler the-dialogue) (char &aux cell)
  510.         (if (graphic-char-p char)
  511.           (ask menu-item
  512.             ;; find first cell matching (in the first dimension)
  513.             (dotimes (c (point-v (table-dimensions)) (ed-beep))
  514.               (setf cell (make-point 0 c))
  515.               (when (char-equal (aref (format nil "~A" (cell-contents cell)) 0)
  516.                                 char)
  517.                 ;; deselect old cell(s)
  518.                 (dolist (cell (selected-cells))
  519.                   (cell-deselect cell))
  520.                 ;; select it and scroll to it (no beep)
  521.                 (cell-select cell)
  522.                 (scroll-to-cell cell)
  523.                 (return nil))))
  524.           (usual-window-key-event-handler char)))
  525.       (if choices (ask menu-item (cell-select (index-to-cell 0))))
  526.       (modal-dialog the-dialogue)))
  527.   ;; Will have to rewrite for version 3.
  528.   #+:TI 
  529.   (do ((chosen nil))
  530.       (chosen chosen)
  531.       (setq chosen (tv:menu-choose (make-item-list choices) message)))
  532.   #+:W9000  
  533.   (do ((result nil)
  534.        (menu-items (nconc (split-lines (trim-right-margin message 60))
  535.               (list :line 
  536.                 " (Choose one of the listed items with the mouse) ")
  537.               (make-item-list choices))))
  538.       ((or (null choices) result) result)
  539.       (setq result
  540.         (second (make-and-activate-menu
  541.              *popup-fd* " Menu Dialogue " menu-items)))
  542.       (if (not (member result choices :test #'equal))
  543.     (setq result nil)))
  544.   #-(or :ccl :ti :W9000)
  545.   (do ((result nil))
  546.       ((or (null choices)
  547.        (member result choices :test #'equal))
  548.        result)
  549.     (format T "~%~A" (trim-right-margin message 60))
  550.     (format T "~{~%  ~35S~^  ~S~}" choices)
  551.     (format T "~%(Enter one of the above):")
  552.     (setf result (read))
  553.     (if (not (member result choices :test #'equal))
  554.     (format T "~%*** Please enter a Lisp form identical to one of the~
  555.                    ~%    above (symbols in the same package, etc.) ..."))))
  556.  
  557. (defun MULTIPLE-MENU-DIALOGUE (choices format &rest args &aux message)
  558.   "multiple-menu-dialogue <choices> <format> &rest <args> - Function
  559.   Prompting with a message constructed from <format> applied to <args>, 
  560.   provides a menu of <choices>, any number of which the user may choose.
  561.   Returns a list of the choices."
  562.   (declare (optimize (safety 1) (space 2) (speed 3)))
  563.   (setq message (apply #'format nil format args))
  564.   #+:CCL 
  565.   (progn
  566.     (trim-right-margin message 60)
  567.     (let* ((message-item
  568.             (oneof *static-text-dialog-item*
  569.                    :dialog-item-text message
  570.                    :dialog-item-size (message-size-in-points message)))
  571.            (menu-item
  572.             (oneof *sequence-dialog-item*
  573.                    :dialog-item-position 
  574.                    (make-point 5 (+ 5 (ask message-item (point-v (dialog-item-size)))))
  575.                    :dialog-item-size  (make-point 350 142)
  576.                    :cell-size         (make-point 350 16)
  577.                    :table-vscrollp t
  578.                    :visible-dimensions  (make-point 1 7)
  579.                    :table-sequence choices
  580.                    :selection-type :disjoint
  581.                    :dialog-item-action
  582.                    '(if (double-click-p)
  583.                       (return-from-modal-dialog
  584.                        (mapcar #'cell-contents (selected-cells))))))
  585.            (ok-button
  586.             (oneof *button-dialog-item*
  587.                    :dialog-item-text " OK "
  588.                    :dialog-item-position 
  589.                    (make-point 395
  590.                                (+ 20 (point-v (ask message-item (dialog-item-size)))))
  591.                    :dialog-item-action
  592.                    #'(lambda () 
  593.                        (ask menu-item 
  594.                          (return-from-modal-dialog
  595.                           (mapcar #'cell-contents (selected-cells)))))
  596.                    :default-button t))
  597.            (cancel-button
  598.             (oneof *button-dialog-item*
  599.                    :dialog-item-text "CANCEL"
  600.                    :dialog-item-position
  601.                    (make-point 385
  602.                                (+ 60 (point-v (ask message-item (dialog-item-size)))))
  603.                    :dialog-item-action
  604.                    #'(lambda () (return-from-modal-dialog :cancel))))
  605.            ;; window size
  606.            (w-h 
  607.             (min (- *screen-width* 20)
  608.                  (max 
  609.                   (+ 10 (point-h (ask message-item (dialog-item-size))))
  610.                   (+ 100 (point-h (ask menu-item (dialog-item-size)))))))
  611.            (w-v
  612.             (min (- *screen-height* *menubar-bottom* 20)
  613.                  (+ (point-v (ask message-item (dialog-item-size)))
  614.                     (point-v (ask menu-item (dialog-item-size))))))
  615.            (the-dialogue
  616.             (oneof *dialog*
  617.                    :window-title "Multiple Menu Dialogue"
  618.                    :window-position *dialogue-position*
  619.                    :window-size (make-point w-h w-v)
  620.                    :window-show t
  621.                    :window-type :double-edge-box
  622.                    :dialog-items 
  623.                    (list ok-button cancel-button message-item menu-item))))
  624.       (declare (fixnum w-h w-v))
  625.       ;; Hack to let some applications say what items should be default.
  626.       (dolist (cell-index *multiple-menu-cells-to-select*)
  627.         (ask menu-item (cell-select (index-to-cell cell-index))))
  628.       ;; Alpha keystrokes will scroll sequence item to the first entry starting
  629.       ;; with <char>. (Assumes list is sorted.)
  630.       (defobfun (window-key-event-handler the-dialogue) (char &aux cell)
  631.         (if (graphic-char-p char)
  632.           (ask menu-item
  633.             ;; find first cell matching (in the first dimension)
  634.             (dotimes (c (point-v (table-dimensions)) (ed-beep))
  635.               (setf cell (make-point 0 c))
  636.               (when (char-equal (aref (format nil "~A" (cell-contents cell)) 0)
  637.                                 char)
  638.                 ;; Select it and scroll to it.  (Not deselecting since multiple.)
  639.                 (cell-select cell)
  640.                 (scroll-to-cell cell)
  641.                 (return nil))))
  642.           (usual-window-key-event-handler char)))
  643.       (modal-dialog the-dialogue)))
  644.  
  645.   ;; Multiple menu choose no longer returns two values, so I have to hack
  646.   ;; a check for whether user returned something.
  647.   #+:TI 
  648.   (do ((chosen nil))
  649.       ((and chosen (if (member '|none of these| chosen) (null (cdr chosen)) t))
  650.        (if (eq (first chosen) '|none of these|) nil chosen))
  651.       (setq chosen
  652.         (tv:multiple-menu-choose (make-item-list (cons '|none of these| choices))
  653.                      message)))
  654.   #+:W9000
  655.   (do ((next-choice nil)
  656.        (selected-items nil)
  657.        (menu-items (nconc (split-lines (trim-right-margin message 60))
  658.               (list :line 
  659.                 " (Choose one of the listed items with the mouse) ")
  660.               (make-item-list choices)
  661.               (list :line '(" I am done choosing " :done)))))
  662.       ((eq next-choice :done) selected-items)
  663.       (setq next-choice
  664.       (second
  665.        (make-and-activate-menu
  666.     *popup-fd* " Multiple Menu Dialogue "
  667.     (if selected-items 
  668.         (append menu-items
  669.             `(:line
  670.               ,(format nil " CURRENTLY SELECTED: ")
  671.               ,(format nil " ~A " selected-items)
  672.               " (Select an item to add, or re-select it to delete) "))
  673.         menu-items))))
  674.     (if (member next-choice choices :test #'equal)
  675.         (if (member next-choice selected-items :test #'equal)
  676.         (setq selected-items
  677.                 (remove next-choice selected-items :test #'equal))
  678.             (push next-choice selected-items))))
  679.   #-(or :ccl :ti :W9000)
  680.   (loop
  681.     (if (null choices) (return nil))
  682.     (let ((chosen nil))
  683.       (format T "~%~A" (trim-right-margin message 60))
  684.       (format T "~{~%  ~35S~^  ~S~}" choices)
  685.       (format T "~%(Enter list of choices):")
  686.       (setq chosen (read))
  687.       (cond ((null (listp chosen))
  688.          (format T "~%*** This primitive interface requires a LIST!"))
  689.         ((set-difference chosen choices :test #'equal)
  690.          (format T 
  691.              "~%*** Your response contains an illegal item.  Each Lisp form must be~
  692.              ~%    identical to one of the above (symbols in the same package, etc.)."))
  693.           ((return chosen))))))
  694.  
  695. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  696. (provide :dialogue)
  697. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  698. ;;; EOF
  699.